perm filename XGP12.F4[1,MUS]1 blob
sn#058153 filedate 1973-09-18 generic text, type T, neo UTF8
00100 SUBROUTINE FMAIN
00200 COMMON/STUF/A(4608),B(4608),C(4608)
00300 CALL DOBLD
00350 CALL DMPXGP
00375 CALL TOREAD(JFN,'XGP.TMP')
00387 CALL DELETE(JFN)
00393 CALL CLOSE(JFN)
00400 RETURN
00500 END
00100 SUBROUTINE DOBLD
00200 COMMON/STUF/D(4608),NK(200),BJ,BH,B(200),NT,N(512)
00300 INTEGER OPAGE
00400 INTEGER D,SIZE
00500 D(1)="400000000000
00600 D(2)=1677721600
00700 J=3
00800 CALL TORITE(JF2,'XGP.TMP')
00900 CALL PTPAGE(0,JF2,NT)
01000 OPAGE=1
01100 NT=0
01200 ISEG=0
01300 1 CONTINUE
01400 BJ=B(199)
01500 BH=B(200)
01600 CALL GT200(B,IEOF)
01700 IF(IEOF.NE.0)GO TO 5
00100 ISEG=ISEG+1
00200 CALL MAKNUM(ISEG,NK)
00300 DO 4 K=1,200
00400 D(J)=16777217
00500 D(J+1)=NK(K)
00600 J=J+2
00700 CALL BUILD(B(K-1),D(J),ICOUNT)
00800 J=J+ICOUNT
00900 IF(J.LT.4400)GO TO 3
01000 IF(J.GT.4608)CALL STRNGO('OVERFLOW IN BUILD ')
01100 NT=NT+1
01200 N(NT)=J-1
01300 DO 2 L=1,4608,512
01400 CALL PTPAGE(OPAGE,JF2,D(L))
01500 OPAGE=OPAGE+1
01600 2 CONTINUE
01700 J=1
01800 3 CONTINUE
01900 4 CONTINUE
02000 GO TO 1
02100 5 CONTINUE
00100 D(J)=1677721600
00200 D(J+1)="400000000000
00300 NT=NT+1
00400 N(NT)=J+1
00500 DO 6 L=1,4608,512
00600 CALL PTPAGE(OPAGE,JF2,D(L))
00700 OPAGE=OPAGE+1
00800 6 CONTINUE
00900 CALL PTPAGE(0,JF2,NT)
01000 CALL CLOSE(JF2)
01100 RETURN
01200 END
00100 SUBROUTINE GT200(A,EOF)
00200 IMPLICIT INTEGER(A-Z)
00300 COMMON/STUF/STUF(9216),B(512),C(1736)
00400 DIMENSION A(2)
00500 DATA FLAG/0/
00600 IF(FLAG.NE.0)GO TO 1
00700 FLAG=-1
00800 CALL TOREAD(JFN)
00900 CALL FILSIZ(JFN,SIZE)
01000 LAST=SIZE/512-1
01100 LEFT=200
01200 PTR=1537
01300 PAGE=-1
01400 1 CONTINUE
01500 LEFT=LEFT-200
01600 PTR=PTR+200
01700 IF(LEFT.GE.200)GO TO 2
01800 IF(LEFT.GT.0)CALL COPY(C(PTR),C,LEFT)
01900 PAGE=PAGE+1
02000 IF(PAGE.GT.LAST)GO TO 3
02100 CALL GTPAGE(PAGE,JFN,B)
02200 CALL CV3P12(B,C(LEFT+1))
02300 CALL MLTT(C(LEFT+1))
02400 LEFT=LEFT+1536
02500 PTR=1
02600 2 CONTINUE
02700 CALL COPY(C(PTR),A,200)
02800 RETURN
02900 3 CONTINUE
03000 CALL CLOSE(JFN)
03100 EOF=-1
03200 CALL ZERO(A,200)
03300 RETURN
03400 END
00100 SUBROUTINE MLTT(A)
00200 DIMENSION A(2)
00300 FAC=1599.0/4096.0
00400 DO 1 J=1,1536
00500 A(J)=FAC*(A(J)+2048.0)
00600 1 CONTINUE
00700 RETURN
00800 END
00100 SUBROUTINE MAKNUM(SEG,N)
00200 IMPLICIT INTEGER(A-Z)
00300 DIMENSION N(2)
00400 LOGICAL T1,T2,T3
00500 CALL ZERO(N,200)
00600 IF(SEG.LT.0.OR.SEG.GT.9999)GO TO 5
00700 D1=SEG/1000
00800 D2=(SEG-1000*D1)/100
00900 D3=(SEG-1000*D1-100*D2)/10
01000 D4=SEG-1000*D1-100*D2-10*D3
01100 T1=D1.EQ.0
01200 T2=D2.EQ.0
01300 T3=D3.EQ.0
01400 IF(T1)GO TO 2
01500 CALL GTGRNM(N(136),D1)
01600 2 CONTINUE
01700 IF(T1.AND.T2)GO TO 3
01800 CALL GTGRNM(N(152),D2)
01900 3 CONTINUE
02000 IF(T1.AND.T2.AND.T3)GO TO 4
02100 CALL GTGRNM(N(168),D3)
02200 4 CONTINUE
02300 CALL GTGRNM(N(184),D4)
02400 RETURN
02500 5 CONTINUE
02600 CALL CRLF
02700 CALL STRNGO('SEG IS OUT OF BOUNDS ')
02800 CALL CRLF
02900 RETURN
03000 END
00100 SUBROUTINE GTGRNM(A,NUM)
00200 DIMENSION A(2)
00300 DIMENSION B(13,10)
00400 DATA (B(J,1),J=1,13)/0,0,0,"300001400000
00500 1,"300001400000
00600 2,"377777400000
00700 3,"377777400000
00800 4,"377777400000
00900 5,"300000000000
01000 6,"300000000000
01100 7,0,0,0/
01200 DATA (B(J,2),J=1,13)/"340014000000,"360014000000,"370006000000
01300 1,"334007000000
01400 2,"316003000000
01500 3,"307001400000
01600 4,"303001400000
01700 5,"303401400000
01800 7,"303403000000
01900 8,"301607000000
02000 9,"300776000000
02100 9,"300374000000
02200 9,"300170000000/
02300 DATA (B(J,3),J=1,13)/"060001400000,"160141400000,"140141400000
02400 2,"140361400000
02500 3,"340361400000
02600 4,"300761400000
02700 5,"300671400000
02800 6,"301671400000
02900 7,"343431400000
03000 8,"143431400000
03100 9,"177415400000
03200 9,"177017400000
03300 9,"076007400000/
03400 DATA (B(J,4),J=1,13)/"016000000000,"017400000000,"017700000000
03500 1,"014340000000
03600 2,"014060000000
03700 3,"014030000000
03800 4,"014017000000
03900 4,"014007000000
04000 5,"377777400000
04100 6,"377777400000
04200 7,"014000000000
04300 8,"014000000000
04400 9,"014000000000/
04500 DATA (B(J,5),J=1,13)/"060077400000,"160077400000,"140061400000
04600 1,"340061400000
04700 2,"300061400000
04800 3,"300061400000
04900 4,"300161400000
05000 5,"300141400000
05100 6,"300341400000
05200 7,"300701400000
05300 8,"361601400000
05400 9,"177401400000
05500 9,"077001400000/
05600 DATA (B(J,6),J=1,13)/"036664000000,"077776000000,"160707000000
05700 1,"140707000000
05800 2,"340303400000
05900 3,"300301400000
06000 4,"300301400000
06100 5,"340301400000
06200 6,"340703400000
06300 7,"161603000000
06400 8,"077407000000
06500 9,"037016000000
06600 9,"016014000000/
06700 DATA (B(J,7),J=1,13)/"000001400000,"000001400000,"000001400000
06800 1,"340001400000
06900 2,"376001400000
07000 3,"077401400000
07100 4,"003701400000
07200 5,"000741400000
07300 6,"000171400000
07400 7,"000037400000
07500 8,"000017400000
07600 9,"000007400000
07700 9,"000003400000/
07800 DATA (B(J,8),J=1,13)/"037474000000,"077776000000,"160767000000
07900 1,"140743000000
08000 2,"340303400000
08100 3,"300301400000
08200 4,"300301400000
08300 5,"300301400000
08400 6,"340303400000
08500 7,"140743000000
08600 8,"160767000000
08700 9,"077776000000
08800 9,"037474000000/
08900 DATA (B(J,9),J=1,13)/"030034000000,"070076000000,"160147000000
09000 1,"140303000000
09100 2,"340603400000
09200 3,"300601400000
09300 4,"300601400000
09400 5,"300601400000
09500 6,"340603400000
09600 7,"140703000000
09700 8,"160747000000
09800 9,"077776000000
09900 9,"037771000000/
10000 DATA (B(J,10),J=1,13)/"003740000000,"017770000000,"037774000000
10100 1,"060006000000
10200 2,"140003000000
10300 3,"300001400000
10400 4,"300001400000
10500 5,"300001400000
10600 6,"140003000000
10700 7,"060006000000
10800 8,"037774000000
10900 9,"017770000000
11000 9,"003740000000/
11100 N=NUM
11200 IF(N.EQ.0)N=10
11300 IF(N.LT.1.OR.N.GT.10)GO TO 2
11400 DO 1 J=1,13
11500 A(J)=B(J,N)
11600 1 CONTINUE
11700 RETURN
11800 2 CONTINUE
11900 CALL CRLF
12000 CALL STRNGO('TROUBLES IN GTGRNM')
12100 CALL CRLF
12200 RETURN
12300 END
00100 SUBROUTINE BUILD(A,D,ICOUNT)
00200 DIMENSION A(2),D(2)
00300 INTEGER D
00400 IF(A(0).LT.A(1))GO TO 2
00500 IF(A(1).LT.A(2))GO TO 1
00600 TOP=1.0+(A(0)+A(1))*0.5
00700 BOT=(A(1)+A(2))*0.5-1.0
00800 GO TO 4
00900 1 CONTINUE
01000 BOT=A(1)
01100 TOP=1.0+(A(0)+A(1))*0.5
01200 FAC=1.0+(A(1)+A(2))*0.5
01300 IF(FAC.GT.TOP)TOP=FAC
01400 GO TO 4
01500 2 CONTINUE
01600 IF(A(1).LT.A(2))GO TO 3
01700 TOP=A(1)
01800 BOT=(A(0)+A(1))*0.5-1.0
01900 FAC=(A(1)+A(2))*0.5-1.0
02000 IF(FAC.LT.BOT)BOT=FAC
02100 GO TO 4
02200 3 CONTINUE
02300 BOT=(A(0)+A(1))*0.5-1.0
02400 TOP=1.0+(A(1)+A(2))*0.5
02500 4 CONTINUE
02600 ICSKIP=BOT
02700 LENGTH=TOP-BOT
02800 IF(LENGTH.LE.0)LENGTH=1
02900 IF(ICSKIP.LE.0)ICSKIP=0
03000 ICOUNT=2
03100 5 CONTINUE
03200 IF(LENGTH.LE.36)GO TO 6
03300 D(ICOUNT)=-1
03400 ICOUNT=ICOUNT+1
03500 LENGTH=LENGTH-36
03600 GO TO 5
03700 6 CONTINUE
03800 IF(LENGTH.LT.36)GO TO 7
03900 D(ICOUNT)=-1
04000 GO TO 8
04100 7 CONTINUE
04200 IFAC=2**(36-LENGTH)-1
04300 IF(LENGTH.EQ.1)IFAC="377777777777
04400 D(ICOUNT)="777777777777.XOR.IFAC
04500 8 CONTINUE
04600 D(1)=ICSKIP*4096+ICOUNT-1
04700 RETURN
04800 END
00100 SUBROUTINE DMPXGP
00200 IMPLICIT INTEGER(A-Z)
00300 COMMON/NT/NT,N(512)
00400 COMMON/STUF/A(4608),B(4608),C(4608)
00500 CALL TOREAD(JFN,'XGP.TMP')
00600 CALL SETXGP
00700 CALL LOCK
00800 CALL GTPAGE(0,JFN,NT)
00900 IF(NT.LT.0)RETURN
01000 CALL POINT(5,JFN)
01100 NUMITR=NT/3
01200 NLEFT=NT-NUMITR*3
01300 IF(NUMITR.EQ.0)GO TO 2
01400 DO 1 NG=1,NUMITR
01500 G=NG*3-2
01600 N1=N(G)
01700 CALL FASTIN(4608,A)
01800 CALL OUTXG1(A,N1)
01900 N2=N(G+1)
02000 CALL FASTIN(4608,B)
02100 CALL OUTXG2(B,N2)
02200 N3=N(G+2)
02300 CALL FASTIN(4608,C)
02400 CALL OUTXG3(C,N3)
02500 1 CONTINUE
02600 2 CONTINUE
02700 IF(NLEFT.NE.0)GO TO 3
02800 A(1)=1677721600
02900 A(2)="400000000000
03000 CALL OUTXG1(A,2)
03100 GO TO 5
03200 3 CONTINUE
03300 G=NUMITR*3+1
03400 N1=N(G)
03500 CALL FASTIN(4608,A)
03600 CALL OUTXG1(A,N1)
03700 IF(NLEFT.NE.1)GO TO 4
03800 B(1)=1677721600
03900 B(2)="400000000000
04000 CALL OUTXG2(B,2)
04100 GO TO 5
04200 4 CONTINUE
04300 N2=N(G+1)
04400 CALL FASTIN(4608,B)
04500 CALL OUTXG2(B,N2)
04600 C(1)=1677721600
04700 C(2)="400000000000
04800 CALL OUTXG3(C,2)
04900 5 CONTINUE
05000 CALL CLOSE(JFN)
05100 CALL RELXGP
05200 CALL UNLOCK
05300 RETURN
05400 END